home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2009 February / PCWFEB09.iso / Software / Linux / Kubuntu 8.10 / kubuntu-8.10-desktop-i386.iso / casper / filesystem.squashfs / usr / share / perl5 / Parse / DebianChangelog.pm
Encoding:
Perl POD Document  |  2008-01-17  |  33.6 KB  |  1,283 lines
  1. #
  2. # Parse::DebianChangelog
  3. #
  4. # Copyright 1996 Ian Jackson
  5. # Copyright 2005 Frank Lichtenheld <frank@lichtenheld.de>
  6. #
  7. #    This program is free software; you can redistribute it and/or modify
  8. #    it under the terms of the GNU General Public License as published by
  9. #    the Free Software Foundation; either version 2 of the License, or
  10. #    (at your option) any later version.
  11. #
  12. #    This program is distributed in the hope that it will be useful,
  13. #    but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. #    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15. #    GNU General Public License for more details.
  16. #
  17. #    You should have received a copy of the GNU General Public License
  18. #    along with this program; if not, write to the Free Software
  19. #    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  20. #
  21.  
  22. =head1 NAME
  23.  
  24. Parse::DebianChangelog - parse Debian changelogs and output them in other formats
  25.  
  26. =head1 SYNOPSIS
  27.  
  28.     use Parse::DebianChangelog;
  29.  
  30.     my $chglog = Parse::DebianChangelog->init( { infile => 'debian/changelog',
  31.                                                  HTML => { outfile => 'changelog.html' } );
  32.     $chglog->html;
  33.  
  34.     # the following is semantically equivalent
  35.     my $chglog = Parse::DebianChangelog->init();
  36.     $chglog->parse( { infile => 'debian/changelog' } );
  37.     $chglog->html( { outfile => 'changelog.html' } );
  38.  
  39.     my $changes = $chglog->dpkg_str( { since => '1.0-1' } );
  40.     print $changes;
  41.  
  42. =head1 DESCRIPTION
  43.  
  44. Parse::DebianChangelog parses Debian changelogs as described in the Debian
  45. policy (version 3.6.2.1 at the time of this writing). See section
  46. L<"SEE ALSO"> for locations where to find this definition.
  47.  
  48. The parser tries to ignore most cruft like # or /* */ style comments,
  49. CVS comments, vim variables, emacs local variables and stuff from
  50. older changelogs with other formats at the end of the file.
  51. NOTE: most of these are ignored silently currently, there is no
  52. parser error issued for them. This should become configurable in the
  53. future.
  54.  
  55. Beside giving access to the details of the parsed file via the
  56. L<"data"> method, Parse::DebianChangelog also supports converting these
  57. changelogs to various other formats. These are currently:
  58.  
  59. =over 4
  60.  
  61. =item dpkg
  62.  
  63. Format as known from L<dpkg-parsechangelog(1)>. All requested entries
  64. (see L<"METHODS"> for an explanation what this means) are returned in
  65. the usual Debian control format, merged in one stanza, ready to be used
  66. in a F<.changes> file.
  67.  
  68. =item rfc822
  69.  
  70. Similar to the C<dpkg> format, but the requested entries are returned
  71. as one stanza each, i.e. they are not merged. This is probably the format
  72. to use if you want a machine-usable representation of the changelog.
  73.  
  74. =item xml
  75.  
  76. Just a simple XML dump of the changelog data. Without any schema or
  77. DTD currently, just some made up XML. The actual format might still
  78. change. Comments and Improvements welcome.
  79.  
  80. =item html
  81.  
  82. The changelog is converted to a somewhat nice looking HTML file with
  83. some nice features as a quick-link bar with direct links to every entry.
  84. NOTE: This is not very configurable yet and was specifically designed
  85. to be used on L<http://packages.debian.org/>. This is planned to be
  86. changed until version 1.0.
  87.  
  88. =back
  89.  
  90. =head2 METHODS
  91.  
  92. =cut
  93.  
  94. package Parse::DebianChangelog;
  95.  
  96. use strict;
  97. use warnings;
  98.  
  99. use Fcntl qw( :flock );
  100. use English;
  101. use Locale::gettext;
  102. use Date::Parse;
  103. use Parse::DebianChangelog::Util qw( :all );
  104. use Parse::DebianChangelog::Entry;
  105.  
  106. our $VERSION = '1.1.1';
  107.  
  108. =pod
  109.  
  110. =head3 init
  111.  
  112. Creates a new object instance. Takes a reference to a hash as
  113. optional argument, which is interpreted as configuration options.
  114. There are currently no supported general configuration options, but
  115. see the other methods for more specific configuration options which
  116. can also specified to C<init>.
  117.  
  118. If C<infile> or C<instring> are specified (see L<parse>), C<parse()>
  119. is called from C<init>. If a fatal error is encountered during parsing
  120. (e.g. the file can't be opened), C<init> will not return a
  121. valid object but C<undef>!
  122.  
  123. =cut
  124.  
  125. sub init {
  126.     my $classname = shift;
  127.     my $config = shift || {};
  128.     my $self = {};
  129.     bless( $self, $classname );
  130.  
  131.     $config->{verbose} = 1 if $config->{debug};
  132.     $self->{config} = $config;
  133.  
  134.     $self->init_filters;
  135.     $self->reset_parse_errors;
  136.  
  137.     if ($self->{config}{infile} || $self->{config}{instring}) {
  138.     defined($self->parse) or return undef;
  139.     }
  140.  
  141.     return $self;
  142. }
  143.  
  144. =pod
  145.  
  146. =head3 reset_parse_errors
  147.  
  148. Can be used to delete all information about errors ocurred during
  149. previous L<parse> runs. Note that C<parse()> also calls this method.
  150.  
  151. =cut
  152.  
  153. sub reset_parse_errors {
  154.     my ($self) = @_;
  155.  
  156.     $self->{errors}{parser} = [];
  157. }
  158.  
  159. sub _do_parse_error {
  160.     my ($self, $file, $line_nr, $error, $line) = @_;
  161.     shift;
  162.  
  163.     push @{$self->{errors}{parser}}, [ @_ ];
  164.  
  165.     $file = substr $file, 0, 20;
  166.     unless ($self->{config}{quiet}) {
  167.     if ($line) {
  168.         warn "WARN: $file(l$NR): $error\nLINE: $line\n";
  169.     } else {
  170.         warn "WARN: $file(l$NR): $error\n";
  171.     }
  172.     }
  173. }
  174.  
  175. =pod
  176.  
  177. =head3 get_parse_errors
  178.  
  179. Returns all error messages from the last L<parse> run.
  180. If called in scalar context returns a human readable
  181. string representation. If called in list context returns
  182. an array of arrays. Each of these arrays contains
  183.  
  184. =over 4
  185.  
  186. =item 1.
  187.  
  188. the filename of the parsed file or C<String> if a string was
  189. parsed directly
  190.  
  191. =item 2.
  192.  
  193. the line number where the error occurred
  194.  
  195. =item 3.
  196.  
  197. an error description
  198.  
  199. =item 4.
  200.  
  201. the original line
  202.  
  203. =back
  204.  
  205. NOTE: This format isn't stable yet and may change in later versions
  206. of this module.
  207.  
  208. =cut
  209.  
  210. sub get_parse_errors {
  211.     my ($self) = @_;
  212.  
  213.     if (wantarray) {
  214.     return @{$self->{errors}{parser}};
  215.     } else {
  216.     my $res = "";
  217.     foreach my $e (@{$self->{errors}{parser}}) {
  218.         if ($e->[3]) {
  219.         $res .= __g( "WARN: %s(l%s): %s\nLINE: %s\n", @$e );
  220.         } else {
  221.         $res .= __g( "WARN: %s(l%s): %s\n", @$e );
  222.         }
  223.     }
  224.     return $res;
  225.     }
  226. }
  227.  
  228. sub _do_fatal_error {
  229.     my ($self, @msg) = @_;
  230.  
  231.     $self->{errors}{fatal} = "@msg";
  232.     warn __g( "FATAL: %s", "@msg")."\n" unless $self->{config}{quiet};
  233. }
  234.  
  235. =pod
  236.  
  237. =head3 get_error
  238.  
  239. Get the last non-parser error (e.g. the file to parse couldn't be opened).
  240.  
  241. =cut
  242.  
  243. sub get_error {
  244.     my ($self) = @_;
  245.  
  246.     return $self->{errors}{fatal};
  247. }
  248.  
  249. =pod
  250.  
  251. =head3 parse
  252.  
  253. Parses either the file named in configuration item C<infile> or the string
  254. saved in configuration item C<instring>.
  255. Accepts a hash ref as optional argument which can contain configuration
  256. items.
  257.  
  258. Returns C<undef> in case of error (e.g. "file not found", B<not> parse
  259. errors) and the object if successful. If C<undef> was returned, you
  260. can get the reason for the failure by calling the L<get_error> method.
  261.  
  262. =cut
  263.  
  264. sub __g {
  265.     my $string = shift;
  266.     return sprintf( dgettext( 'Parse-DebianChangelog', $string ), @_ );
  267. }
  268.  
  269. sub parse {
  270.     my ($self, $config) = @_;
  271.  
  272.     foreach my $c (keys %$config) {
  273.     $self->{config}{$c} = $config->{$c};
  274.     }
  275.  
  276.     my ($fh, $file);
  277.     if ($file = $self->{config}{infile}) {
  278.     open $fh, '<', $file or do {
  279.         $self->_do_fatal_error( __g( "can't open file %s: %s",
  280.                      $file, $! ));
  281.         return undef;
  282.     };
  283.     flock $fh, LOCK_SH or do {
  284.         $self->_do_fatal_error( __g( "can't lock file %s: %s",
  285.                      $file, $! ));
  286.         return undef;
  287.     };
  288.     } elsif (my $string = $self->{config}{instring}) {
  289.     eval { require IO::String };
  290.     if ($@) {
  291.         $self->_do_fatal_error( __g( "can't load IO::String: %s",
  292.                      $@ ));
  293.         return undef;
  294.     }
  295.     $fh = IO::String->new( $string );
  296.     $file = 'String';
  297.     } else {
  298.     $self->_do_fatal_error( __g( 'no changelog file specified' ));
  299.     return undef;
  300.     }
  301.  
  302.     $self->reset_parse_errors;
  303.  
  304.     $self->{data} = [];
  305.  
  306. # based on /usr/lib/dpkg/parsechangelog/debian
  307.     my $expect='first heading';
  308.     my $entry = Parse::DebianChangelog::Entry->init();
  309.     my $blanklines = 0;
  310.     my $unknowncounter = 1; # to make version unique, e.g. for using as id
  311.  
  312.     while (<$fh>) {
  313.     s/\s*\n$//;
  314. #    printf(STDERR "%-39.39s %-39.39s\n",$expect,$_);
  315.     if (m/^(\w[-+0-9a-z.]*) \(([^\(\) \t]+)\)((\s+[-0-9a-z]+)+)\;/i) {
  316.         unless ($expect eq 'first heading'
  317.             || $expect eq 'next heading or eof') {
  318.         $entry->{ERROR} = [ $file, $NR,
  319.                   __g( "found start of entry where expected %s",
  320.                        $expect ), "$_" ];
  321.         $self->_do_parse_error(@{$entry->{ERROR}});
  322.         }
  323.         unless ($entry->is_empty) {
  324.         $entry->{'Closes'} = find_closes( $entry->{Changes} );
  325. #            print STDERR, Dumper($entry);
  326.         push @{$self->{data}}, $entry;
  327.         $entry = Parse::DebianChangelog::Entry->init();
  328.         }
  329.         {
  330.         $entry->{'Source'} = "$1";
  331.         $entry->{'Version'} = "$2";
  332.         $entry->{'Header'} = "$_";
  333.         ($entry->{'Distribution'} = "$3") =~ s/^\s+//;
  334.         $entry->{'Changes'} = $entry->{'Urgency_Comment'} = '';
  335.         $entry->{'Urgency'} = $entry->{'Urgency_LC'} = 'unknown';
  336.         }
  337.         (my $rhs = $POSTMATCH) =~ s/^\s+//;
  338.         my %kvdone;
  339. #        print STDERR "RHS: $rhs\n";
  340.         for my $kv (split(/\s*,\s*/,$rhs)) {
  341.         $kv =~ m/^([-0-9a-z]+)\=\s*(.*\S)$/i ||
  342.             $self->_do_parse_error($file, $NR,
  343.                        __g( "bad key-value after \`;': \`%s'", $kv ));
  344.         my $k = ucfirst $1;
  345.         my $v = $2;
  346.         $kvdone{$k}++ && $self->_do_parse_error($file, $NR,
  347.                                __g( "repeated key-value %s", $k ));
  348.         if ($k eq 'Urgency') {
  349.             $v =~ m/^([-0-9a-z]+)((\s+.*)?)$/i ||
  350.             $self->_do_parse_error($file, $NR,
  351.                           __g( "badly formatted urgency value" ),
  352.                           $v);
  353.             $entry->{'Urgency'} = "$1";
  354.             $entry->{'Urgency_LC'} = lc("$1");
  355.             $entry->{'Urgency_Comment'} = "$2";
  356.         } elsif ($k =~ m/^X[BCS]+-/i) {
  357.             # Extensions - XB for putting in Binary,
  358.             # XC for putting in Control, XS for putting in Source
  359.             $entry->{$k}= $v;
  360.         } else {
  361.             $self->_do_parse_error($file, $NR,
  362.                       __g( "unknown key-value key %s - copying to XS-%s", $k, $k ));
  363.             $entry->{ExtraFields}{"XS-$k"} = $v;
  364.         }
  365.         }
  366.         $expect= 'start of change data';
  367.         $blanklines = 0;
  368.     } elsif (m/^(;;\s*)?Local variables:/io) {
  369.         last; # skip Emacs variables at end of file
  370.     } elsif (m/^vim:/io) {
  371.         last; # skip vim variables at end of file
  372.     } elsif (m/^\$\w+:.*\$/o) {
  373.         next; # skip stuff that look like a CVS keyword
  374.     } elsif (m/^\# /o) {
  375.         next; # skip comments, even that's not supported
  376.     } elsif (m,^/\*.*\*/,o) {
  377.         next; # more comments
  378.     } elsif (m/^(\w+\s+\w+\s+\d{1,2} \d{1,2}:\d{1,2}:\d{1,2}\s+[\w\s]*\d{4})\s+(.*)\s+(<|\()(.*)(\)|>)/o
  379.          || m/^(\w+\s+\w+\s+\d{1,2},?\s*\d{4})\s+(.*)\s+(<|\()(.*)(\)|>)/o
  380.          || m/^(\w[-+0-9a-z.]*) \(([^\(\) \t]+)\)\;?/io
  381.          || m/^([\w.+-]+)(-| )(\S+) Debian (\S+)/io
  382.          || m/^Changes from version (.*) to (.*):/io
  383.          || m/^Changes for [\w.+-]+-[\w.+-]+:?$/io
  384.          || m/^Old Changelog:$/io
  385.          || m/^(?:\d+:)?\w[\w.+~-]*:?$/o) {
  386.         # save entries on old changelog format verbatim
  387.         # we assume the rest of the file will be in old format once we
  388.         # hit it for the first time
  389.         $self->{oldformat} = "$_\n";
  390.         $self->{oldformat} .= join "", <$fh>;
  391.     } elsif (m/^\S/) {
  392.         $self->_do_parse_error($file, $NR,
  393.                   __g( "badly formatted heading line" ), "$_");
  394.     } elsif (m/^ \-\- (.*) <(.*)>(  ?)((\w+\,\s*)?\d{1,2}\s+\w+\s+\d{4}\s+\d{1,2}:\d\d:\d\d\s+[-+]\d{4}(\s+\([^\\\(\)]\))?)$/o) {
  395.         $expect eq 'more change data or trailer' ||
  396.         $self->_do_parse_error($file, $NR,
  397.                        __g( "found trailer where expected %s",
  398.                         $expect ), "$_");
  399.         if ($3 ne '  ') {
  400.         $self->_do_parse_error($file, $NR,
  401.                        __g( "badly formatted trailer line" ),
  402.                        "$_");
  403.         }
  404.         $entry->{'Trailer'} = $_;
  405.         $entry->{'Maintainer'} = "$1 <$2>" unless $entry->{'Maintainer'};
  406.         unless($entry->{'Date'} && defined $entry->{'Timestamp'}) {
  407.         $entry->{'Date'} = "$4";
  408.         $entry->{'Timestamp'} = str2time($4);
  409.         unless (defined $entry->{'Timestamp'}) {
  410.             $self->_do_parse_error( $file, $NR,
  411.                         __g( "couldn't parse date %s",
  412.                          "$4" ) );
  413.         }
  414.         }
  415.         $expect = 'next heading or eof';
  416.     } elsif (m/^ \-\-/) {
  417.         $entry->{ERROR} = [ $file, $NR,
  418.                   __g( "badly formatted trailer line" ), "$_" ];
  419.         $self->_do_parse_error(@{$entry->{ERROR}});
  420. #        $expect = 'next heading or eof'
  421. #        if $expect eq 'more change data or trailer';
  422.     } elsif (m/^\s{2,}(\S)/) {
  423.         $expect eq 'start of change data'
  424.         || $expect eq 'more change data or trailer'
  425.         || do {
  426.             $self->_do_parse_error($file, $NR,
  427.                 __g( "found change data where expected %s",
  428.                  $expect ), "$_");
  429.             if (($expect eq 'next heading or eof')
  430.             && !$entry->is_empty) {
  431.             # lets assume we have missed the actual header line
  432.             $entry->{'Closes'} = find_closes( $entry->{Changes} );
  433. #            print STDERR, Dumper($entry);
  434.             push @{$self->{data}}, $entry;
  435.             $entry = Parse::DebianChangelog::Entry->init();
  436.             $entry->{Source} =
  437.                 $entry->{Distribution} = $entry->{Urgency} =
  438.                 $entry->{Urgency_LC} = 'unknown';
  439.             $entry->{Version} = 'unknown'.($unknowncounter++);
  440.             $entry->{Urgency_Comment} = '';
  441.             $entry->{ERROR} = [ $file, $NR,
  442.                         __g( "found change data where expected %s",
  443.                          $expect ), "$_" ];
  444.             }
  445.         };
  446.         $entry->{'Changes'} .= (" \n" x $blanklines)." $_\n";
  447.         if (!$entry->{'Items'} || ($1 eq '*')) {
  448.         $entry->{'Items'} ||= [];
  449.         push @{$entry->{'Items'}}, "$_\n";
  450.         } else {
  451.         $entry->{'Items'}[-1] .= (" \n" x $blanklines)." $_\n";
  452.         }
  453.         $blanklines = 0;
  454.         $expect = 'more change data or trailer';
  455.     } elsif (!m/\S/) {
  456.         next if $expect eq 'start of change data'
  457.         || $expect eq 'next heading or eof';
  458.         $expect eq 'more change data or trailer'
  459.         || $self->_do_parse_error($file, $NR,
  460.                      __g( "found blank line where expected %s",
  461.                           $expect ));
  462.         $blanklines++;
  463.     } else {
  464.         $self->_do_parse_error($file, $NR, __g( "unrecognised line" ),
  465.                    "$_");
  466.         ($expect eq 'start of change data'
  467.         || $expect eq 'more change data or trailer')
  468.         && do {
  469.             # lets assume change data if we expected it
  470.             $entry->{'Changes'} .= (" \n" x $blanklines)." $_\n";
  471.             if (!$entry->{'Items'}) {
  472.             $entry->{'Items'} ||= [];
  473.             push @{$entry->{'Items'}}, "$_\n";
  474.             } else {
  475.             $entry->{'Items'}[-1] .= (" \n" x $blanklines)." $_\n";
  476.             }
  477.             $blanklines = 0;
  478.             $expect = 'more change data or trailer';
  479.             $entry->{ERROR} = [ $file, $NR, __g( "unrecognised line" ),
  480.                     "$_" ];
  481.         };
  482.     }
  483.     }
  484.  
  485.     $expect eq 'next heading or eof'
  486.     || do {
  487.         $entry->{ERROR} = [ $file, $NR,
  488.                 __g( "found eof where expected %s",
  489.                      $expect ) ];
  490.         $self->_do_parse_error( @{$entry->{ERROR}} );
  491.     };
  492.     unless ($entry->is_empty) {
  493.     $entry->{'Closes'} = find_closes( $entry->{Changes} );
  494.     push @{$self->{data}}, $entry;
  495.     }
  496.  
  497.     if ($self->{config}{infile}) {
  498.     close $fh or do {
  499.         $self->_do_fatal_error( __g( "can't close file %s: %s",
  500.                      $file, $! ));
  501.         return undef;
  502.     };
  503.     }
  504.  
  505. #    use Data::Dumper;
  506. #    print Dumper( $self );
  507.  
  508.     return $self;
  509. }
  510.  
  511. =pod
  512.  
  513. =head3 data
  514.  
  515. C<data> returns an array (if called in list context) or a reference
  516. to an array of Parse::DebianChangelog::Entry objects which each
  517. represent one entry of the changelog.
  518.  
  519. This is currently merely a placeholder to enable users to get to the
  520. raw data, expect changes to this API in the near future.
  521.  
  522. This method supports the common output options described in
  523. section L<"COMMON OUTPUT OPTIONS">.
  524.  
  525. =cut
  526.  
  527. sub data {
  528.     my ($self, $config) = @_;
  529.  
  530.     my $data = $self->{data};
  531.     if ($config) {
  532.     $self->{config}{DATA} = $config if $config;
  533.     $data = $self->_data_range( $config ) or return undef;
  534.     }
  535.     return @$data if wantarray;
  536.     return $data;
  537. }
  538.  
  539. sub __sanity_check_range {
  540.     my ( $data, $from, $to, $since, $until, $start, $end ) = @_;
  541.  
  542.     if (($$start || $$end) && ($$from || $$since || $$to || $$until)) {
  543.     warn( __g( "you can't combine 'count' or 'offset' with any other range option" ) ."\n");
  544.     $$from = $$since = $$to = $$until = '';
  545.     }
  546.     if ($$from && $$since) {
  547.     warn( __g( "you can only specify one of 'from' and 'since'" ) ."\n");
  548.     $$from = '';
  549.     }
  550.     if ($$to && $$until) {
  551.     warn( __g( "you can only specify one of 'to' and 'until'" ) ."\n");
  552.     $$to = '';
  553.     }
  554.     if ($$since && ($data->[0]{Version} eq $$since)) {
  555.     warn( __g( "'since' option specifies most recent version" ) ."\n");
  556.     $$since = '';
  557.     }
  558.     if ($$until && ($data->[$#{$data}]{Version} eq $$until)) {
  559.     warn( __g( "'until' option specifies oldest version" ) ."\n");
  560.     $$until = '';
  561.     }
  562.     $$start = 0 if $$start < 0;
  563.     return if $$start > $#$data;
  564.     $$end = $#$data if $$end > $#$data;
  565.     return if $$end < 0;
  566.     $$end = $$start if $$end < $$start;
  567.     #TODO: compare versions
  568.     return 1;
  569. }
  570.  
  571. sub _data_range {
  572.     my ($self, $config) = @_;
  573.  
  574.     my $data = $self->data or return undef;
  575.  
  576.     return [ @$data ] if $config->{all};
  577.  
  578.     my $since = $config->{since} || '';
  579.     my $until = $config->{until} || '';
  580.     my $from = $config->{from} || '';
  581.     my $to = $config->{to} || '';
  582.     my $count = $config->{count} || 0;
  583.     my $offset = $config->{offset} || 0;
  584.  
  585.     return if $offset and not $count;
  586.     if ($offset > 0) {
  587.     $offset -= ($count < 0);
  588.     } elsif ($offset < 0) {
  589.     $offset = $#$data + ($count > 0) + $offset;
  590.     } else {
  591.     $offset = $#$data if $count < 0;
  592.     }
  593.     my $start = my $end = $offset;
  594.     $start += $count+1 if $count < 0;
  595.     $end += $count-1 if $count > 0;
  596.  
  597.     return unless __sanity_check_range( $data, \$from, \$to,
  598.                     \$since, \$until,
  599.                     \$start, \$end );
  600.  
  601.  
  602.     unless ($from or $to or $since or $until or $start or $end) {
  603.     return [ @$data ] if $config->{default_all} and not $count;
  604.     return [ $data->[0] ];
  605.     }
  606.  
  607.     return [ @{$data}[$start .. $end] ] if $start or $end;
  608.  
  609.     my @result;
  610.  
  611.     my $include = 1;
  612.     $include = 0 if $to or $until;
  613.     foreach (@$data) {
  614.     my $v = $_->{Version};
  615.     $include = 1 if $v eq $to;
  616.     last if $v eq $since;
  617.  
  618.     push @result, $_ if $include;
  619.  
  620.     $include = 1 if $v eq $until;
  621.     last if $v eq $from;
  622.     }
  623.  
  624.     return \@result;
  625. }
  626.  
  627. =pod
  628.  
  629. =head3 dpkg
  630.  
  631. (and B<dpkg_str>)
  632.  
  633. C<dpkg> returns a hash (in list context) or a hash reference
  634. (in scalar context) where the keys are field names and the values are
  635. field values. The following fields are given:
  636.  
  637. =over 4
  638.  
  639. =item Source
  640.  
  641. package name (in the first entry)
  642.  
  643. =item Version
  644.  
  645. packages' version (from first entry)
  646.  
  647. =item Distribution
  648.  
  649. target distribution (from first entry)
  650.  
  651. =item Urgency
  652.  
  653. urgency (highest of all printed entries)
  654.  
  655. =item Maintainer
  656.  
  657. person that created the (first) entry
  658.  
  659. =item Date
  660.  
  661. date of the (first) entry
  662.  
  663. =item Closes
  664.  
  665. bugs closed by the entry/entries, sorted by bug number
  666.  
  667. =item Changes
  668.  
  669. content of the the entry/entries
  670.  
  671. =back
  672.  
  673. C<dpkg_str> returns a stringified version of this hash which should look
  674. exactly like the output of L<dpkg-parsechangelog(1)>. The fields are
  675. ordered like in the list above.
  676.  
  677. Both methods only support the common output options described in
  678. section L<"COMMON OUTPUT OPTIONS">.
  679.  
  680. =head3 dpkg_str
  681.  
  682. See L<dpkg>.
  683.  
  684. =cut
  685.  
  686. our ( %FIELDIMPS, %URGENCIES );
  687. BEGIN {
  688.     my $i=100;
  689.     grep($FIELDIMPS{$_}=$i--,
  690.      qw(Source Version Distribution Urgency Maintainer Date Closes
  691.         Changes));
  692.     $i=1;
  693.     grep($URGENCIES{$_}=$i++,
  694.      qw(low medium high critical emergency));
  695. }
  696.  
  697. sub dpkg {
  698.     my ($self, $config) = @_;
  699.  
  700.     $self->{config}{DPKG} = $config if $config;
  701.  
  702.     $config = $self->{config}{DPKG} || {};
  703.     my $data = $self->_data_range( $config ) or return undef;
  704.  
  705.     my %f;
  706.     foreach my $field (qw( Urgency Source Version
  707.                Distribution Maintainer Date )) {
  708.     $f{$field} = $data->[0]{$field};
  709.     }
  710.  
  711.     $f{Changes} = get_dpkg_changes( $data->[0] );
  712.     $f{Closes} = [ @{$data->[0]{Closes}} ];
  713.  
  714.     my $first = 1; my $urg_comment = '';
  715.     foreach my $entry (@$data) {
  716.     $first = 0, next if $first;
  717.  
  718.     my $oldurg = $f{Urgency} || '';
  719.     my $oldurgn = $URGENCIES{$f{Urgency}} || -1;
  720.     my $newurg = $entry->{Urgency_LC} || '';
  721.     my $newurgn = $URGENCIES{$entry->{Urgency_LC}} || -1;
  722.     $f{Urgency} = ($newurgn > $oldurgn) ? $newurg : $oldurg;
  723.     $urg_comment .= $entry->{Urgency_Comment};
  724.  
  725.     $f{Changes} .= "\n .".get_dpkg_changes( $entry );
  726.     push @{$f{Closes}}, @{$entry->{Closes}};
  727.     }
  728.  
  729.     $f{Closes} = join " ", sort { $a <=> $b } @{$f{Closes}};
  730.     $f{Urgency} .= $urg_comment;
  731.  
  732.     return %f if wantarray;
  733.     return \%f;
  734. }
  735.  
  736. sub dpkg_str {
  737.     return data2rfc822( scalar dpkg(@_), \%FIELDIMPS );
  738. }
  739.  
  740. =pod
  741.  
  742. =head3 rfc822
  743.  
  744. (and B<rfc822_str>)
  745.  
  746. C<rfc822> returns an array of hashes (in list context) or a reference
  747. to this array (in scalar context) where each hash represents one entry
  748. in the changelog. For the format of such a hash see the description
  749. of the L<"dpkg"> method (while ignoring the remarks about which
  750. values are taken from the first entry).
  751.  
  752. C<rfc822_str> returns a stringified version of this hash which looks
  753. similar to the output of dpkg-parsechangelog but instead of one
  754. stanza the output contains one stanza for each entry.
  755.  
  756. Both methods only support the common output options described in
  757. section L<"COMMON OUTPUT OPTIONS">.
  758.  
  759. =head3 rfc822_str
  760.  
  761. See L<rfc822>.
  762.  
  763. =cut
  764.  
  765. sub rfc822 {
  766.     my ($self, $config) = @_;
  767.  
  768.     $self->{config}{RFC822} = $config if $config;
  769.  
  770.     $config = $self->{config}{RFC822} || {};
  771.     my $data = $self->_data_range( $config ) or return undef;
  772.     my @out_data;
  773.  
  774.     foreach my $entry (@$data) {
  775.     my %f;
  776.     foreach my $field (qw( Urgency Source Version
  777.                Distribution Maintainer Date )) {
  778.         $f{$field} = $entry->{$field};
  779.     }
  780.  
  781.     $f{Urgency} .= $entry->{Urgency_Comment};
  782.     $f{Changes} = get_dpkg_changes( $entry );
  783.     $f{Closes} = join " ", sort { $a <=> $b } @{$entry->{Closes}};
  784.     push @out_data, \%f;
  785.     }
  786.  
  787.     return @out_data if wantarray;
  788.     return \@out_data;
  789. }
  790.  
  791. sub rfc822_str {
  792.     return data2rfc822_mult( scalar rfc822(@_), \%FIELDIMPS );
  793. }
  794.  
  795. sub __version2id {
  796.     my $version = shift;
  797.     $version =~ s/[^\w.:-]/_/go;
  798.     return "version$version";
  799. }
  800.  
  801. =pod
  802.  
  803. =head3 xml
  804.  
  805. (and B<xml_str>)
  806.  
  807. C<xml> converts the changelog to some free-form (i.e. there is neither
  808. a DTD or a schema for it) XML.
  809.  
  810. The method C<xml_str> is an alias for C<xml>.
  811.  
  812. Both methods support the common output options described in
  813. section L<"COMMON OUTPUT OPTIONS"> and additionally the following
  814. configuration options (as usual to give
  815. in a hash reference as parameter to the method call):
  816.  
  817. =over 4
  818.  
  819. =item outfile
  820.  
  821. directly write the output to the file specified
  822.  
  823. =back
  824.  
  825. =head3 xml_str
  826.  
  827. See L<xml>.
  828.  
  829. =cut
  830.  
  831. sub xml {
  832.     my ($self, $config) = @_;
  833.  
  834.     $self->{config}{XML} = $config if $config;
  835.     $config = $self->{config}{XML} || {};
  836.     $config->{default_all} = 1 unless exists $config->{all};
  837.     my $data = $self->_data_range( $config ) or return undef;
  838.     my %out_data;
  839.     $out_data{Entry} = [];
  840.  
  841.     require XML::Simple;
  842.     import XML::Simple qw( :strict );
  843.  
  844.     foreach my $entry (@$data) {
  845.     my %f;
  846.     foreach my $field (qw( Urgency Source Version
  847.                    Distribution Closes )) {
  848.         $f{$field} = $entry->{$field};
  849.     }
  850.     foreach my $field (qw( Maintainer Changes )) {
  851.         $f{$field} = [ $entry->{$field} ];
  852.     }
  853.  
  854.     $f{Urgency} .= $entry->{Urgency_Comment};
  855.     $f{Date} = { timestamp => $entry->{Timestamp},
  856.              content => $entry->{Date} };
  857.     push @{$out_data{Entry}}, \%f;
  858.     }
  859.  
  860.     my $xml_str;
  861.     my %xml_opts = ( SuppressEmpty => 1, KeyAttr => {},
  862.              RootName => 'Changelog' );
  863.     $xml_str = XMLout( \%out_data, %xml_opts );
  864.     if ($config->{outfile}) {
  865.     open my $fh, '>', $config->{outfile} or return undef;
  866.     flock $fh, LOCK_EX or return undef;
  867.  
  868.     print $fh $xml_str;
  869.  
  870.     close $fh or return undef;
  871.     }
  872.  
  873.     return $xml_str;
  874. }
  875.  
  876. sub xml_str {
  877.     return xml(@_);
  878. }
  879.  
  880. =pod
  881.  
  882. =head3 html
  883.  
  884. (and B<html_str>)
  885.  
  886. C<html> converts the changelog to a HTML file with some nice features
  887. such as a quick-link bar with direct links to every entry. The HTML
  888. is generated with the help of HTML::Template. If you want to change
  889. the output you should use the default template provided with this module
  890. as a base and read the documentation of HTML::Template to understand
  891. how to edit it.
  892.  
  893. The method C<html_str> is an alias for C<html>.
  894.  
  895. Both methods support the common output options described in
  896. section L<"COMMON OUTPUT OPTIONS"> and additionally the following
  897. configuration options (as usual to give
  898. in a hash reference as parameter to the method call):
  899.  
  900. =over 4
  901.  
  902. =item outfile
  903.  
  904. directly write the output to the file specified
  905.  
  906. =item template
  907.  
  908. template file to use, defaults to tmpl/default.tmpl, so you
  909. most likely want to override that.
  910. NOTE: The plan is to provide a configuration file for the module
  911. later to be able to use sane defaults here.
  912.  
  913. =item style
  914.  
  915. path to the CSS stylesheet to use (a default might be specified
  916. in the template and will be honoured, see the default template
  917. for an example)
  918.  
  919. =item print_style
  920.  
  921. path to the CSS stylesheet to use for printing (see the notes for
  922. C<style> about default values)
  923.  
  924. =back
  925.  
  926. =head3 html_str
  927.  
  928. See L<html>.
  929.  
  930. =cut
  931.  
  932. sub html {
  933.     my ($self, $config) = @_;
  934.  
  935.     $self->{config}{HTML} = $config if $config;
  936.     $config = $self->{config}{HTML} || {};
  937.     $config->{default_all} = 1 unless exists $config->{all};
  938.     my $data = $self->_data_range( $config ) or return undef;
  939.  
  940.     require CGI;
  941.     import CGI qw( -no_xhtml -no_debug );
  942.     require HTML::Template;
  943.  
  944.     my $template = HTML::Template->new(filename => $config->{template}
  945.                        || 'tmpl/default.tmpl',
  946.                        die_on_bad_params => 0);
  947.     $template->param( MODULE_NAME => ref($self),
  948.               MODULE_VERSION => $VERSION,
  949.               GENERATED_DATE => gmtime()." UTC",
  950.               SOURCE_NEWEST => $data->[0]{Source},
  951.               VERSION_NEWEST => $data->[0]{Version},
  952.               MAINTAINER_NEWEST => $data->[0]{Maintainer},
  953.               );
  954.  
  955.     $template->param( CSS_FILE_SCREEN => $config->{style} )
  956.     if $config->{style};
  957.     $template->param( CSS_FILE_PRINT => $config->{print_style} )
  958.     if $config->{print_style};
  959.  
  960.     my $cgi = new CGI;
  961.     $cgi->autoEscape(0);
  962.  
  963.     my %navigation;
  964.     my $last_year;
  965.     foreach my $entry (@$data) {
  966.     my $year = $last_year; # try to deal gracefully with unparsable dates
  967.     if (defined $entry->{Timestamp}) {
  968.         $year = (gmtime($entry->{Timestamp}))[5] + 1900;
  969.         $last_year = $year;
  970.     }
  971.  
  972.     $year ||= (($entry->{Date} =~ /\s(\d{4})\s/) ? $1 : (gmtime)[5] + 1900);
  973.  
  974.     $navigation{$year}{NAV_VERSIONS} ||= [];
  975.     $navigation{$year}{NAV_YEAR} ||= $year;
  976.  
  977.     $entry->{Maintainer} ||= 'unknown';
  978.     $entry->{Date} ||= 'unknown';
  979.     push @{$navigation{$year}{NAV_VERSIONS}},
  980.            { NAV_VERSION_ID => __version2id($entry->{Version}),
  981.          NAV_VERSION => $entry->{Version},
  982.          NAV_MAINTAINER => $entry->{Maintainer},
  983.          NAV_DATE => $entry->{Date} };
  984.     }
  985.     my @nav_years;
  986.     foreach my $y (reverse sort keys %navigation) {
  987.     push @nav_years, $navigation{$y};
  988.     }
  989.     $template->param( OLDFORMAT => (($self->{oldformat}||'') ne ''),
  990.               NAV_YEARS => \@nav_years );
  991.  
  992.  
  993.     my %years;
  994.     $last_year = undef;
  995.     foreach my $entry (@$data) {
  996.     my $year = $last_year; # try to deal gracefully with unparsable dates
  997.     if (defined $entry->{Timestamp}) {
  998.         $year = (gmtime($entry->{Timestamp}))[5] + 1900;
  999.     }
  1000.     $year ||= (($entry->{Date} =~ /\s(\d{4})\s/) ? $1 : (gmtime)[5] + 1900);
  1001.  
  1002.     if (!$last_year || ($year < $last_year)) {
  1003.         $last_year = $year;
  1004.     }
  1005.  
  1006.     $years{$last_year}{CONTENT_VERSIONS} ||= [];
  1007.     $years{$last_year}{CONTENT_YEAR} ||= $last_year;
  1008.  
  1009.     my $text = $self->apply_filters( 'html::changes',
  1010.                      $entry->{Changes}, $cgi );
  1011.  
  1012.     (my $maint_name = $entry->{Maintainer} ) =~ s|<([a-zA-Z0-9_\+\-\.]+\@([a-zA-Z0-9][\w\.+\-]+\.[a-zA-Z]{2,}))>||o;
  1013.     my $maint_mail = $1;
  1014.  
  1015.     my $parse_error;
  1016.     $parse_error = $cgi->p( { -class=>'parse_error' },
  1017.                 "(There has been a parse error in the entry above, if some values don't make sense please check the original changelog)" )
  1018.         if $entry->{ERROR};
  1019.  
  1020.     push @{$years{$last_year}{CONTENT_VERSIONS}}, {
  1021.         CONTENT_VERSION => $entry->{Version},
  1022.         CONTENT_VERSION_ID => __version2id($entry->{Version}),
  1023.         CONTENT_URGENCY => $entry->{Urgency}.$entry->{Urgency_Comment},
  1024.         CONTENT_URGENCY_NORM => $entry->{Urgency_LC},
  1025.         CONTENT_DISTRIBUTION => $entry->{Distribution},
  1026.         CONTENT_DISTRIBUTION_NORM => lc($entry->{Distribution}),
  1027.         CONTENT_SOURCE => $entry->{Source},
  1028.         CONTENT_CHANGES => $text,
  1029.         CONTENT_CHANGES_UNFILTERED => $entry->{Changes},
  1030.         CONTENT_DATE => $entry->{Date},
  1031.         CONTENT_MAINTAINER_NAME => $maint_name,
  1032.         CONTENT_MAINTAINER_EMAIL => $maint_mail,
  1033.         CONTENT_PARSE_ERROR => $parse_error,
  1034.     };
  1035.     }
  1036.     my @content_years;
  1037.     foreach my $y (reverse sort keys %years) {
  1038.     push @content_years, $years{$y};
  1039.     }
  1040.     $template->param( OLDFORMAT_CHANGES => $self->{oldformat},
  1041.               CONTENT_YEARS => \@content_years );
  1042.  
  1043.     my $html_str = $template->output;
  1044.  
  1045.     if ($config->{outfile}) {
  1046.     open my $fh, '>', $config->{outfile} or return undef;
  1047.     flock $fh, LOCK_EX or return undef;
  1048.  
  1049.     print $fh $html_str;
  1050.  
  1051.     close $fh or return undef;
  1052.     }
  1053.  
  1054.     return $html_str;
  1055. }
  1056.  
  1057. sub html_str {
  1058.     return html(@_);
  1059. }
  1060.  
  1061.  
  1062. =pod
  1063.  
  1064. =head3 init_filters
  1065.  
  1066. not yet documented
  1067.  
  1068. =cut
  1069.  
  1070. sub init_filters {
  1071.     my ($self) = @_;
  1072.  
  1073.     require Parse::DebianChangelog::ChangesFilters;
  1074.  
  1075.     $self->{filters} = {};
  1076.  
  1077.     $self->{filters}{'html::changes'} =
  1078.     [ @Parse::DebianChangelog::ChangesFilters::all_filters ];
  1079. }
  1080.  
  1081. =pod
  1082.  
  1083. =head3 apply_filters
  1084.  
  1085. not yet documented
  1086.  
  1087. =cut
  1088.  
  1089. sub apply_filters {
  1090.     my ($self, $filter_class, $text, $data) = @_;
  1091.  
  1092.     foreach my $f (@{$self->{filters}{$filter_class}}) {
  1093.     $text = &$f( $text, $data );
  1094.     }
  1095.     return $text;
  1096. }
  1097.  
  1098. =pod
  1099.  
  1100. =head3 add_filter, delete_filter, replace_filter
  1101.  
  1102. not yet documented
  1103.  
  1104. =cut
  1105.  
  1106. sub add_filter {
  1107.     my ($self, $filter_class, $filter, $pos) = @_;
  1108.  
  1109.     $self->{filters}{$filter_class} ||= [];
  1110.     unless ($pos) {
  1111.     push @{$self->{filters}{$filter_class}}, $filter;
  1112.     } elsif ($pos == 1) {
  1113.     unshift @{$self->{filters}{$filter_class}}, $filter;
  1114.     } elsif ($pos > 1) {
  1115.     my $length = @{$self->{filters}{$filter_class}};
  1116.     $self->{filters}{$filter_class} =
  1117.         [ @{$self->{filters}{$filter_class}[0 .. ($pos-2)]}, $filter,
  1118.           @{$self->{filters}{$filter_class}[($pos-1) .. ($length-1)]} ];
  1119.     }
  1120.  
  1121.     return $self;
  1122. }
  1123.  
  1124. sub delete_filter {
  1125.     my ($self, $filter_class, $filter) = @_;
  1126.  
  1127.     my $pos;
  1128.     unless (ref $filter) {
  1129.     $pos = $filter;
  1130.  
  1131.     return delete $self->{filters}{$filter_class}[$pos];
  1132.     }
  1133.  
  1134.     $self->{filters}{$filter_class} ||= [];
  1135.     my @deleted;
  1136.     for my $i (0 .. $#{$self->{filters}{$filter_class}}) {
  1137.     push @deleted, delete $self->{filters}{$filter_class}[$i]
  1138.         if $self->{filters}{$filter_class}[$i] == $filter;
  1139.     }
  1140.  
  1141.     return @deleted;
  1142. }
  1143.  
  1144. sub replace_filter {
  1145.     my ($self, $filter_class, $filter, @new_filters) = @_;
  1146.  
  1147.     my @pos;
  1148.     unless (ref $filter) {
  1149.     $pos[0] = $filter;
  1150.     } else {
  1151.     $self->{filters}{$filter_class} ||= [];
  1152.     for my $i (0 .. $#{$self->{filters}{$filter_class}}) {
  1153.         push @pos, $i
  1154.         if $self->{filters}{$filter_class}[$i] == $filter;
  1155.     }
  1156.     }
  1157.  
  1158.     foreach my $p (@pos) {
  1159.     $self->delete_filter( $filter_class, $p );
  1160.  
  1161.     foreach my $f (@new_filters) {
  1162.         $self->add_filter( $filter_class, $f, $p++);
  1163.     }
  1164.     }
  1165.  
  1166.     return $self;
  1167. }
  1168.  
  1169. 1;
  1170. __END__
  1171.  
  1172. =head1 COMMON OUTPUT OPTIONS
  1173.  
  1174. The following options are supported by all output methods,
  1175. all take a version number as value:
  1176.  
  1177. =over 4
  1178.  
  1179. =item since
  1180.  
  1181. Causes changelog information from all versions strictly
  1182. later than B<version> to be used.
  1183.  
  1184. (works exactly like the C<-v> option of dpkg-parsechangelog).
  1185.  
  1186. =item until
  1187.  
  1188. Causes changelog information from all versions strictly
  1189. earlier than B<version> to be used.
  1190.  
  1191. =item from
  1192.  
  1193. Similar to C<since> but also includes the information for the
  1194. specified B<version> itself.
  1195.  
  1196. =item to
  1197.  
  1198. Similar to C<until> but also includes the information for the
  1199. specified B<version> itself.
  1200.  
  1201. =back
  1202.  
  1203. The following options also supported by all output methods but
  1204. don't take version numbers as values:
  1205.  
  1206. =over 4
  1207.  
  1208. =item all
  1209.  
  1210. If set to a true value, all entries of the changelog are returned,
  1211. this overrides all other options. While the XML and HTML formats
  1212. default to all == true, this does of course not overwrite other
  1213. options unless it is set explicitly with the call.
  1214.  
  1215. =item count
  1216.  
  1217. Expects a signed integer as value. Returns C<value> entries from the
  1218. top of the changelog if set to a positive integer, and C<abs(value)>
  1219. entries from the tail if set to a negative integer.
  1220.  
  1221. =item offset
  1222.  
  1223. Expects a signed integer as value. Changes the starting point for
  1224. C<count>, either counted from the top (positive integer) or from
  1225. the tail (negative integer). C<offset> has no effect if C<count>
  1226. wasn't given as well.
  1227.  
  1228. =back
  1229.  
  1230. Some examples for the above options. Imagine an example changelog with
  1231. entries for the versions 1.2, 1.3, 2.0, 2.1, 2.2, 3.0 and 3.1.
  1232.  
  1233.             Call                               Included entries
  1234.  C<E<lt>formatE<gt>({ since =E<gt> '2.0' })>  3.1, 3.0, 2.2
  1235.  C<E<lt>formatE<gt>({ until =E<gt> '2.0' })>  1.3, 1.2
  1236.  C<E<lt>formatE<gt>({ from =E<gt> '2.0' })>   3.1, 3.0, 2.2, 2.1, 2.0
  1237.  C<E<lt>formatE<gt>({ to =E<gt> '2.0' })>     2.0, 1.3, 1.2
  1238.  C<E<lt>formatE<gt>({ count =E<gt> 2 }>>      3.1, 3.0
  1239.  C<E<lt>formatE<gt>({ count =E<gt> -2 }>>     1.3, 1.2
  1240.  C<E<lt>formatE<gt>({ count =E<gt> 3,
  1241.               offset=E<gt> 2 }>>      2.2, 2.1, 2.0
  1242.  C<E<lt>formatE<gt>({ count =E<gt> 2,
  1243.               offset=E<gt> -3 }>>     2.0, 1.3
  1244.  C<E<lt>formatE<gt>({ count =E<gt> -2,
  1245.               offset=E<gt> 3 }>>      3.0, 2.2
  1246.  C<E<lt>formatE<gt>({ count =E<gt> -2,
  1247.               offset=E<gt> -3 }>>     2.2, 2.1
  1248.  
  1249. Any combination of one option of C<since> and C<from> and one of
  1250. C<until> and C<to> returns the intersection of the two results
  1251. with only one of the options specified.
  1252.  
  1253. =head1 SEE ALSO
  1254.  
  1255. Parse::DebianChangelog::Entry, Parse::DebianChangelog::ChangesFilters
  1256.  
  1257. Description of the Debian changelog format in the Debian policy:
  1258. L<http://www.debian.org/doc/debian-policy/ch-source.html#s-dpkgchangelog>.
  1259.  
  1260. =head1 AUTHOR
  1261.  
  1262. Frank Lichtenheld, E<lt>frank@lichtenheld.deE<gt>
  1263.  
  1264. =head1 COPYRIGHT AND LICENSE
  1265.  
  1266. Copyright (C) 2005 by Frank Lichtenheld
  1267.  
  1268. This program is free software; you can redistribute it and/or modify
  1269. it under the terms of the GNU General Public License as published by
  1270. the Free Software Foundation; either version 2 of the License, or
  1271. (at your option) any later version.
  1272.  
  1273. This program is distributed in the hope that it will be useful,
  1274. but WITHOUT ANY WARRANTY; without even the implied warranty of
  1275. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  1276. GNU General Public License for more details.
  1277.  
  1278. You should have received a copy of the GNU General Public License
  1279. along with this program; if not, write to the Free Software
  1280. Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  1281.  
  1282. =cut
  1283.